home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
GENSUBS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
6KB
|
322 lines
unit gensubs;
interface
uses dos,gentypes;
function strr (i:{integer}longint):mstr;
function streal (r:real):mstr;
function strlong (l:longint):mstr;
function valu (q:mstr):integer;
function valul (q:mstr):longint;
function addrstr (p:pointer):sstr;
procedure parse3 (s:lstr; var a,b,c:word);
function packtime (var dt:datetime):longint;
function now:longint;
function timestr (time:longint):sstr;
function timeval (q:sstr):longint;
function timepart (time:longint):longint;
function datestr (time:longint):sstr;
function dateval (q:sstr):longint;
function datepart (time:longint):longint;
function upstring (a:anystr):anystr;
function lowstring (s:anystr):anystr;
function yastring (s:sstr):boolean;
function match (s1,s2:anystr):boolean;
function devicename (name:lstr):boolean;
function exist (n:lstr):boolean;
procedure appendfile (name:lstr; var q:text);
procedure addexitproc (p:pointer);
procedure doneexitproc;
implementation
const maxexitprocs=25;
var exitstack:array [1..maxexitprocs] of pointer;
exitstackptr:integer;
type packedtimerec=record
date,time:word
end;
function strr (i:{integer}longint):mstr;
var b:mstr;
begin
str (i,b);
strr:=b
end;
function streal (r:real):mstr;
var b:mstr;
begin
str (r:0:0,b);
streal:=b
end;
function strlong (l:longint):mstr;
var v:mstr;
begin
str (l,v);
strlong:=v
end;
function valu (q:mstr):integer;
var i,s,pu:integer;
r:real;
begin
valu:=-1;
if length(q)=0 then exit;
if not (q[1] in ['0'..'9','-']) then exit;
if length(q)>5 then exit;
val (q,r,s);
if s<>0 then exit;
if (r<=32767.0) and (r>=-32767.0)
then valu:=round(r)
end;
function valul (q:mstr):longint;
var i,s,pu:integer;
r:real;
begin
valul:=0;
if length(q)=0 then exit;
if not (q[1] in ['0'..'9','-']) then exit;
if pos(' ',q)<>0 then q:=copy(q,1,pos(' ',q)-1);
val (q,r,s);
if s<>0 then exit;
valul:=round(r)
end;
function addrstr (p:pointer):sstr;
function hexstr (n:integer):sstr;
function hexbytestr (b:byte):sstr;
const hexchars:array[0..15] of char='0123456789ABCDEF';
begin
hexbytestr:=hexchars[b shr 4]+hexchars[b and 15]
end;
begin
hexstr:=hexbytestr (hi(n))+hexbytestr(lo(n))
end;
begin
addrstr:=hexstr(seg(p^))+':'+hexstr(ofs(p^))
end;
procedure parse3 (s:lstr; var a,b,c:word);
var p:integer;
procedure parse1 (var n:word);
var ns:lstr;
begin
ns[0]:=#0;
while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
ns:=ns+s[p];
p:=p+1
end;
if length(ns)=0
then n:=0
else n:=valu(ns);
if p<length(s) then p:=p+1
end;
begin
p:=1;
parse1 (a);
parse1 (b);
parse1 (c)
end;
function packtime (var dt:datetime):longint;
var l:longint;
begin
dos.packtime (dt,l);
packtime:=l
end;
function now:longint;
var dt:datetime;
t:word;
l:longint;
begin
gettime (dt.hour,dt.min,dt.sec,t);
getdate (dt.year,dt.month,dt.day,t);
l:=packtime (dt);
now:=l
end;
function timestr (time:longint):sstr;
var h1:integer;
ms:sstr;
dt:datetime;
const ampmstr:array [false..true] of string[2]=('am','pm');
begin
unpacktime (time,dt);
h1:=dt.hour;
if h1=0
then h1:=12
else if h1>12
then h1:=h1-12;
ms:=strr(dt.min);
if dt.min<10 then ms:='0'+ms;
timestr:=strr(h1)+':'+ms+' '+ampmstr[dt.hour>11]
end;
function datestr (time:longint):sstr;
var dt:datetime;
begin
unpacktime (time,dt);
datestr:=strr(dt.month)+'/'+strr(dt.day)+'/'+strr(dt.year-1900)
end;
function timepart (time:longint):longint;
begin
timepart:=time and $0000ffff;
end;
function datepart (time:longint):longint;
begin
datepart:=time and $ffff0000;
end;
procedure cleardatetime (var dt:datetime);
begin
unpacktime (0,dt)
end;
function timeval (q:sstr):longint;
var h1,t:word;
k:char;
dt:datetime;
begin
cleardatetime (dt);
parse3 (q,h1,dt.min,t);
k:=upcase(q[length(q)-1]);
if h1 in [1..11] then begin
dt.hour:=h1;
if k='P' then dt.hour:=dt.hour+12
end else
if k='P' then dt.hour:=12
else dt.hour:=0;
timeval:=timepart(packtime(dt))
end;
function dateval (q:sstr):longint;
var dt:datetime;
begin
cleardatetime (dt);
parse3 (q,dt.month,dt.day,dt.year);
if ((dt.year<100) and (dt.year>00)) then dt.year:=dt.year+1900;
dateval:=datepart(packtime(dt))
end;
function upstring (a:anystr):anystr;
var cnt:integer;
begin
for cnt:=1 to length(a) do a[cnt]:=upcase(a[cnt]);
upstring:=a
end;
function lowstring (s:anystr):anystr;
var cnt:integer;
begin
for cnt:=1 to length(s) do begin
if s[cnt] in ['A'..'Z'] then s[cnt]:=chr(ord(s[cnt])+32);
end;
lowstring:=s;
end;
function yastring (s:sstr):boolean;
var cnt:integer;
begin
yastring:=false;
for cnt:=1 to length(s) do s[cnt]:=upcase(s[cnt]);
if length(s)>0 then
yastring:=true else
yastring:=false
end;
function match (s1,s2:anystr):boolean;
var cnt:integer;
begin
match:=false;
if length(s1)<>length(s2) then exit;
for cnt:=1 to length(s1) do
if upcase(s1[cnt])<>upcase(s2[cnt])
then exit;
match:=true
end;
function devicename (name:lstr):boolean;
var f:file;
n:integer absolute f;
r:registers;
begin
devicename:=false;
assign (f,name);
reset (f);
if ioresult<>0 then exit;
r.bx:=n;
r.ax:=$4400;
intr ($21,r);
devicename:=(r.dx and 128)=128;
close (f)
end;
function exist (n:lstr):boolean;
var f:file;
i:integer;
begin
i:=0;
assign (f,n);
reset (f);
i:=ioresult;
exist:=i=0;
close (f);
i:=ioresult
end;
procedure appendfile (name:lstr; var q:text);
var n:integer;
b:boolean;
f:file of char;
begin
close (q);
n:=ioresult;
assign (q,name);
assign (f,name);
reset (f);
b:=(ioresult<>0) or (filesize(f)=0);
close (f);
n:=ioresult;
if b
then rewrite (q)
else append (q)
end;
procedure addexitproc (p:pointer);
begin
inc (exitstackptr);
if exitstackptr>maxexitprocs then begin
writeln ('Too many exit procedures');
halt (255)
end else begin
exitstack[exitstackptr]:=exitproc;
exitproc:=p
end
end;
procedure doneexitproc;
begin
exitproc:=exitstack[exitstackptr];
dec (exitstackptr)
end;
begin
exitstackptr:=0
end.